home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / faq-s.zip / USERRET.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-04  |  7KB  |  278 lines
  1. {$R-,S-,I-,D-,F-,V-,B-,N-,L+ }
  2.  
  3. unit userret;
  4.  
  5. interface
  6.  
  7. uses dos,
  8.      gentypes,gensubs,subs1,configrt,mailret,textret;
  9.  
  10. procedure writeufile (var u:userrec; n:integer);
  11. procedure writeurec;
  12. procedure readurec;
  13. function validuname (m:mstr):boolean;
  14. function lookupuname (n:integer):mstr;
  15. function lookupuser (var uname:mstr):integer;
  16. function adduser (var u:userrec):integer;
  17. procedure delallmail (n:integer);
  18. procedure deleteuser (n:integer);
  19. procedure updateuserstats (disconnecting:boolean);
  20. function postcallratio (var u:userrec):real;
  21. function fitsspecs (var u:userrec; var us:userspecsrec):boolean;
  22.  
  23. implementation
  24.  
  25. procedure writeufile (var u:userrec; n:integer);
  26. begin
  27.   seek (ufile,n);
  28.   write (ufile,u);
  29.   seek (uhfile,n);
  30.   write (uhfile,u.handle)
  31. end;
  32.  
  33. procedure writeurec;
  34. begin
  35.   if unum<1 then exit;
  36.   urec.level:=ulvl;
  37.   urec.handle:=unam;
  38.   writeufile (urec,unum)
  39. end;
  40.  
  41. procedure readurec;
  42. begin
  43.   seek (ufile,unum);
  44.   read (ufile,urec);
  45.   ulvl:=urec.level;
  46.   unam:=urec.handle
  47. end;
  48.  
  49. function validuname (m:mstr):boolean;
  50. var n:integer;
  51. begin
  52.   if length(m)>0
  53.     then if (m<>'?') and (m[1]<>'#') and (m[1]<>'/') and (m[length(m)]<>'*')
  54.                      and (not match(m,'new')) and (not match(m,'q'))
  55.       then if valu(m)=0
  56.         then validuname:=true
  57.         else begin
  58.           validuname:=false;
  59.           writeln (^B'Invalid user name!')
  60.         end
  61. end;
  62.  
  63. function lookupuname (n:integer):mstr;
  64. var un:mstr;
  65. begin
  66.   if (n<1) or (n>numusers) then un:='* Unknown *' else begin
  67.     seek (uhfile,n);
  68.     read (uhfile,un);
  69.     if length(un)=0 then un:='* User Disappeared *'
  70.   end;
  71.   lookupuname:=un
  72. end;
  73.  
  74. function lookupuser (var uname:mstr):integer;
  75. var cnt,s:integer;
  76.     wildcarding:boolean;
  77.     k:char;
  78.     uh:mstr;
  79. begin
  80.   lookupuser:=0;
  81.   if length(uname)=0 then exit;
  82.   if uname[1]='/' then exit;
  83.   if uname[1]='#' then delete (uname,1,1);
  84.   wildcarding:=uname[length(uname)]='*';
  85.   if wildcarding then uname[0]:=pred(uname[0]);
  86.   val (uname,cnt,s);
  87.   if (s=0) and (cnt>0) and (cnt<=numusers) then begin
  88.     seek (uhfile,cnt);
  89.     read (uhfile,uh);
  90.     if length (uh)>0 then begin
  91.       lookupuser:=cnt;
  92.       uname:=uh
  93.     end;
  94.     exit
  95.   end;
  96.   seek (uhfile,1);
  97.   for cnt:=1 to numusers do
  98.     begin
  99.       read (uhfile,uh);
  100.       if wildcarding and (uh<>'')
  101.         then if match(copy(uh,1,length(uname)),uname)
  102.           then
  103.             begin
  104.               write (^B,uh,' [y/n/x]: ');
  105.               repeat
  106.                 read (k);
  107.                 k:=upcase(k)
  108.               until hungupon or (k in ['Y','N','X']);
  109.               writeln (k);
  110.               case upcase(k) of
  111.                 'Y':begin
  112.                       lookupuser:=cnt;
  113.                       uname:=uh;
  114.                       exit
  115.                     end;
  116.                  'X':exit
  117.               end
  118.             end
  119.           else
  120.         else if match (uh,uname)
  121.           then
  122.             begin
  123.               lookupuser:=cnt;
  124.               uname:=uh;
  125.               exit
  126.             end
  127.     end
  128. end;
  129.  
  130. function adduser (var u:userrec):integer;
  131. var un:userrec;
  132.     num,cnt:integer;
  133.     level:integer;
  134.     handle:mstr;
  135.     password:sstr;
  136. label found;
  137. begin
  138.   num:=numusers+1;
  139.   for cnt:=1 to numusers do begin
  140.     seek (ufile,cnt);
  141.     read (ufile,un);
  142.     if length(un.handle)=0 then
  143.       begin
  144.         num:=cnt;
  145.         goto found
  146.       end
  147.   end;
  148.   if num>maxusers then begin
  149.     adduser:=-1;
  150.     exit
  151.   end;
  152.   numusers:=num;
  153.   found:
  154.   handle:=u.handle;
  155.   level:=u.level;
  156.   password:=u.password;
  157.   fillchar (u,sizeof(u),0);
  158.   u.config:=[lowercase,eightycols,linefeeds,postprompts];
  159.   u.udlevel:=defudlevel;
  160.   u.gflevel:=0;
  161.   u.udpoints:=defudpoints;
  162.   u.emailannounce:=-1;
  163.   u.infoform1:=-1;
  164.   u.infoform2:=-1;
  165.   u.infoform3:=-1;
  166.   u.infoform4:=-1;
  167.   u.infoform5:=-1;
  168.   u.displaylen:=25;
  169.   u.handle:=handle;
  170.   u.level:=level;
  171.   u.password:=password;
  172.   u.note:=newusernote;
  173.   u.downk:=0;
  174.   u.upk:=0;
  175.   writeufile (u,num);
  176.   adduser:=num
  177. end;
  178.  
  179. procedure delallmail (n:integer);
  180. var cnt,delled:integer;
  181.     m:mailrec;
  182.     u:userrec;
  183. begin
  184.   cnt:=-1;
  185.   delled:=0;
  186.   repeat
  187.     cnt:=searchmail(cnt,n);
  188.     if cnt>0 then begin
  189.       delmail(cnt);
  190.       cnt:=cnt-1;
  191.       delled:=delled+1
  192.     end
  193.   until cnt=0;
  194.   if delled>0 then writeln (^B'Mail deleted: ',delled);
  195.   writeurec;
  196.   seek (ufile,n);
  197.   read (ufile,u);
  198.   deletetext (u.infoform1);
  199.   deletetext (u.infoform2);
  200.   deletetext (u.infoform3);
  201.   deletetext (u.infoform4);
  202.   deletetext (u.infoform5);
  203.   deletetext (u.emailannounce);
  204.   u.infoform1:=-1;
  205.   u.infoform2:=-1;
  206.   u.infoform3:=-1;
  207.   u.infoform4:=-1;
  208.   u.infoform5:=-1;
  209.   u.emailannounce:=-1;
  210.   writeufile (u,n);
  211.   readurec
  212. end;
  213.  
  214. procedure deleteuser (n:integer);
  215. var u:userrec;
  216. begin
  217.   delallmail (n);
  218.   fillchar (u,sizeof(u),0);
  219.   u.infoform1:=-1;
  220.   u.infoform2:=-1;
  221.   u.infoform3:=-1;
  222.   u.infoform4:=-1;
  223.   u.infoform5:=-1;
  224.   u.emailannounce:=-1;
  225.   writeufile (u,n)
  226. end;
  227.  
  228. procedure updateuserstats (disconnecting:boolean);
  229. var timeon:integer;
  230. begin
  231.   with urec do begin
  232.     timeon:=timeontoday;
  233.     timetoday:=timetoday-timeon;
  234.     if timetoday<0 then timetoday:=0;
  235.     totaltime:=totaltime+timeon;
  236.     if tempsysop then begin
  237.       ulvl:=regularlevel;
  238.       writeln (usr,'[Disabling temporary sysop powers]');
  239.       writeurec
  240.     end;
  241.     if disconnecting and (numon=1) then begin
  242.       if (ulvl<=defuserlevel) and (logonlevel<>0) then ulvl:=logonlevel;
  243.     end;
  244.     if not disconnecting then writedataarea
  245.   end;
  246.   writeurec
  247. end;
  248.  
  249. function postcallratio (var u:userrec):real;
  250. begin
  251.   if u.numon=0
  252.     then postcallratio:=0
  253.     else postcallratio:=u.nbu/u.numon
  254. end;
  255.  
  256. function fitsspecs (var u:userrec; var us:userspecsrec):boolean;
  257. var days:integer;
  258.     pcr:real;
  259.     thisyear,thismonth,thisday,t:word;
  260.     lastcall:datetime;
  261.  
  262.   function inrange (n,min,max:integer):boolean;
  263.   begin
  264.     inrange:=(n>=min) and (n<=max)
  265.   end;
  266.  
  267. begin
  268.   unpacktime (u.laston,lastcall);
  269.   getdate (thisyear,thismonth,thisday,t);
  270.   days:=(thisyear-lastcall.year)*365+(thismonth-lastcall.month)*30+
  271.         (thisday-lastcall.day);
  272.   pcr:=postcallratio (u);
  273.   fitsspecs:=inrange (u.level,us.minlevel,us.maxlevel) and
  274.              inrange (days,us.minlaston,us.maxlaston) and
  275.              (pcr>=us.minpcr) and (pcr<=us.maxpcr)
  276. end;
  277.  
  278. end.